home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / demo100.arc / MAKELIST.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-09-06  |  5.3 KB  |  216 lines
  1. {$C-}     { disable control char interpretation and thus user interupt }
  2.  
  3. program MakeList;
  4.  
  5. type
  6.   filenametype = string[127];
  7.   linetype     = string[80];
  8.  
  9. const
  10.   ch           : char = ' ';
  11.   heading      = 'Writing input list file: ';
  12.   byebye       = 'Program Makelist Terminated.';
  13.   ExecQuestion = 'Do you wish to run Demo.Com (Y,N)?';
  14.   ExecMessage  = 'Executing Demo.Com';
  15.   Title        = 'MAKELIST INPUT LIST GENERATOR';
  16.  
  17. var
  18.   CmdLine       : string[127] absolute cseg:$80; { address of command line }
  19.   i,x,y,j,k,
  20.   oldj,oldk     : integer;
  21.   filename,
  22.   OldFilename,
  23.   CmdParm       : string[127];
  24.   outfile       : text;
  25.   ExecFile      : file;
  26.  
  27. procedure CursorOff;  { directly manipulates the CGA (color graphics card) }
  28.   begin
  29.     port[$3d4]:=10;   { 6845 crt controller ind reg;points to reg to rec }
  30.     port[$3d5]:=8;    { data which is output to reg here;strt scan ln=8  }
  31.     port[$3d4]:=11;   { index to reg for cursor stop scan ln             }
  32.     port[$3d5]:=7;    { stop scan line=7                                 }
  33.  end;
  34.  
  35. procedure CursorOn;   { directly manipulates the CGA (color graphics card) }
  36.   begin
  37.     port[$3d4]:=10;
  38.     port[$3d5]:=6;    { start scan line = 6 ( normal ) }
  39.     port[$3d4]:=11;
  40.     port[$3d5]:=7;    { stop scan line = 7 ( normal )  }
  41.   end;
  42.  
  43. function Center(str : linetype) : integer;
  44.   begin
  45.     Center := 39-round(length(str)/2)
  46.   end;
  47.  
  48. function Exist(filename: filenametype) : boolean;
  49.   var
  50.     tempfile : file;
  51.     dummy    : integer;
  52.  
  53.   begin
  54.     assign(tempfile,filename);
  55.     {$I-}              { disable automatic generation of I/O checking code }
  56.     reset(tempfile);   { attempt to open file }
  57.     Exist:=(IOresult=0); { standard function IOresult give 0 if no error }
  58.     close(tempfile);   { just in case the file exists, it must be closed or   }
  59.     dummy := IOresult; { end up with too many open files and prog. will abort }
  60.     {$I+}              { re-enable automatic generation of I/O checking code  }
  61.   end;
  62.  
  63. procedure FixScreen;  { prepare to end program }
  64.   begin
  65.     textmode(C80);       { Reset color-text mode }
  66.     textcolor(14);       { I like bright yellow  }
  67.     textbackground(0);   { and black background  }
  68.     clrscr;
  69.     gotoxy(Center(byebye),12);
  70.     cursoroff;
  71.     write(byebye);
  72.     delay(1000);
  73.     gotoxy(1,24);
  74.     cursoron;
  75.     halt                 { End program           }
  76.   end;
  77.  
  78. begin    { makelist }
  79.  
  80.   j := 2000;
  81.   k := 3;
  82.   i := 0;
  83.   clrscr;
  84.   gotoxy(Center(Title),12);
  85.   cursoroff;
  86.   write(Title);
  87.   delay(2500);
  88.   clrscr;
  89.   gotoxy(20,1);
  90.   cursoron;
  91.   write('Name of list file to create: ');
  92.   x := wherex;
  93.   y := wherey;
  94.   read(filename);
  95.   while filename = '' do
  96.     begin
  97.       gotoxy(x,y);
  98.       read(filename)
  99.     end;
  100.   CmdParm := filename;
  101.   assign(outfile,filename);
  102.   rewrite(outfile);
  103.  
  104.   clrscr;
  105.   gotoxy(Center(heading+filename),1);
  106.   cursoroff;
  107.   write(heading+filename);
  108.   filename := '';
  109.  
  110.   repeat              { input lines of list file and write to disk }
  111.     i := i + 1;
  112.     gotoxy(10,5);
  113.     cursoroff;
  114.     write('Picture file name # ');
  115.     textcolor(11);
  116.     write(i);
  117.     textcolor(14);
  118.     write(' (use no extension): ');
  119.     clreol;
  120.     textcolor(13);
  121.     oldfilename := filename;
  122.     x := wherex;
  123.     y := wherey;
  124.     cursoron;
  125.     readln(filename);
  126.     if filename = '' then
  127.       begin
  128.         cursoroff;
  129.         filename := oldfilename;
  130.         while filename = '' do
  131.           begin
  132.             gotoxy(x,y);
  133.             cursoron;
  134.             read(filename)
  135.           end;
  136.         gotoxy(x,y);
  137.         cursoroff;
  138.         write(filename);
  139.       end;
  140.     textcolor(14);
  141.  
  142.     gotoxy(10,7);
  143.     cursoroff;
  144.     write('Duration of display (milliseconds...1000 = 1 sec.): ');
  145.     clreol;
  146.     textcolor(13);
  147.     oldj := j;
  148.     j := -1;
  149.     cursoron;
  150.     read(j);
  151.     if j < 0 then
  152.       begin
  153.         j := oldj;
  154.         write(j)
  155.       end;
  156.     textcolor(14);
  157.  
  158.     gotoxy(10,9);
  159.     cursoroff;
  160.     write('Palette desired (0 to 3): ');
  161.     clreol;
  162.     textcolor(13);
  163.     oldk := k;
  164.     k := -1;
  165.     cursoron;
  166.     read(k);
  167.     if k < 0 then
  168.       begin
  169.         k := oldk;
  170.         write(k)
  171.       end;
  172.     textcolor(14);
  173.  
  174.     writeln(outfile,filename,' ',j,' ',k);
  175.  
  176.     gotoxy(10,13);
  177.     textcolor(12);
  178.     cursoroff;
  179.     write('Hit <Enter> to continue, <Esc> to end.');
  180.     textcolor(14);
  181.  
  182.     read(kbd,ch);
  183.     while ch <> #13 do   { <cr>  = end program }
  184.       if ch = #27 then   { <esc> = try to run Demo.Com }
  185.         begin
  186.           close(outfile);
  187.           clrscr;
  188.           gotoxy(Center(ExecQuestion),12);
  189.           cursoroff;
  190.           write(ExecQuestion);
  191.           ch := ' ';
  192.           while not (upcase(ch) in ['Y','N']) do
  193.             begin
  194.               read(kbd,ch);
  195.               if (Upcase(ch) = 'Y') and Exist('Demo.Com') then
  196.                 begin
  197.                   clrscr;
  198.                   CmdLine := CmdParm;
  199.                   gotoxy(Center(ExecMessage),12);
  200.                   cursoroff;
  201.                   write(ExecMessage);
  202.                   delay(1000);
  203.                   assign(ExecFile,'Demo.Com');
  204.                   execute(ExecFile)
  205.                 end
  206.             end;
  207.           FixScreen;
  208.         end
  209.         else
  210.           read(kbd,ch);
  211.     gotoxy(1,13);
  212.     clreol
  213.  
  214.   until true = false
  215.  
  216. end.